-- Copyright 2012, Google Inc.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
--
--     * Redistributions of source code must retain the above copyright notice,
--       this list of conditions and the following disclaimer.
--     * Redistributions in binary form must reproduce the above copyright
--       notice, this list of conditions and the following disclaimer in the
--       documentation and/or other materials provided with the distribution.
--     * Neither the name of Google Inc. nor the names of its contributors may
--       be used to endorse or promote products derived from this software
--       without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-- ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
-- LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-- CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
-- SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-- INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
-- CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-- POSSIBILITY OF SUCH DAMAGE.

-- Author: Paul Brauner (polux@google.com)

module Text.Templating.Go.Compiler (
  compile
) where

import Data.Char
import Data.Monoid
import Data.List
--import Text.Printf (printf)

import Text.Templating.Go.Data

{- documents -}

data Doc = TextDoc String | AppendDoc Doc Doc | Parens Doc
  deriving Show

instance Monoid Doc where
  mempty = TextDoc ""
  mappend = AppendDoc

(<>) :: Monoid m => m -> m -> m
(<>) = mappend

nil :: Monoid m => m
nil = mempty

inter d ds = mconcat (intersperse d ds) 

parens (Parens d) = d
parens d = Parens d

td = TextDoc

doc2str = concat . reverse . doc2str' []
  where doc2str' acc (Parens d) = 
          doc2str' acc $ (td "(") <> d <> (td ")")
        doc2str' acc (TextDoc s) = s:acc
        doc2str' acc (AppendDoc d1 d2) = 
           let acc' = doc2str' acc d1
           in doc2str' acc' d2

{- javascript -}

escape :: String -> String
escape ""          = ""
escape ('\b' : cs) = "\\b"  ++ escape cs
escape ('\f' : cs) = "\\f"  ++ escape cs
escape ('\n' : cs) = "\\n"  ++ escape cs
escape ('\r' : cs) = "\\r"  ++ escape cs
escape ('\t' : cs) = "\\t"  ++ escape cs
escape ('\\' : cs) = "\\\\" ++ escape cs
escape ('\'' : cs) = "\\'"  ++ escape cs
escape (c : cs) = c : escape cs

braces d = td "{" <> d <> td "}"

quotes d = (td "\"") <> d <> (td "\"")

toExpr :: [Doc] -> Doc
toExpr instrs = closurize (toExpr' instrs)
  where toExpr' [i]    = (td "return ") <> i <> (td ";")
        toExpr' (i:is) = i <> (td ";") <> toExpr' is
        closurize d = (td "(function (){") <> d <> (td "})()")

ifThenElse a b c =
  parens a <> (td "?") <> parens b <> (td ":") <> parens c 

fun args expr =
  (td "function(") <> inter (td ",") args <>
  (td ") { return ") <> parens expr <> (td "; }")

fundecl f args expr = 
  (td "function ") <> f <> (td "(") <> inter (td ",") args <>
  (td ") { return ") <> parens expr <> (td "; }")                    

app f args = parens f <> (td "(") <> inter (td ",") args <> (td ")")

data Binding = (:=) { bvar :: Doc, bval :: Doc } 
letIn bindings expr =
  app (fun (map bvar bindings) expr) (map bval bindings)

jConcat expr = parens expr <> (td ".join('')") 

isEmptyString expr = parens expr <> (td "=== ''")

obj fields = braces (inter (td ",") content)
  where content = [quotes key <> td ":" <> parens val
                  | (key := val) <- fields]
  

{- compilation -}

compile :: Template -> String
compile = doc2str . topToJs

_dot = td "__dot"
_dollar = td "__dollar_"
_isFun = td "__isFun"
_isArray = td "__isArray"
_isObject = td "__isObject"
_tmp = td "__tmp"
_map = td "__map"
_mapIdx = td "__mapidx"
_isEmpty = td "__isEmpty"
_funs = td "__funs"

predefs = obj
  [ td "not" := fun [td "x"] (td "!x")
  , td "and" := fun [td "x", td "y"] (td "x && y")
  , td "or" := fun [td "x", td "y"] (td "x || y")
  , td "len" := fun [td "x"] (td "x.length")
  , td "call" := fun [td "f"]
      (td "f.apply(null, Array.prototype.slice.apply(arguments).slice(1))")
  , td "urlquery" := fun [td "s"] (td "encodeURIComponent(s)")
  ]

prelude :: [Doc]
prelude =
  [ fundecl _isFun [td "x"]
      (td "x && ({}).toString.call(x) === '[object Function]'")
  , fundecl _isArray [td "x"]
      (td "x && ({}).toString.call(x) === '[object Array]'")
  , fundecl _isObject [td "x"]
      (td "x && ({}).toString.call(x) === '[object Object]'")
  , td "function " <> _isEmpty <> td "(o) {" <>
      td "if (o.length && o.length > 0) return false;" <>
      td "for (var k in o) { if (hasOwnProperty.call(o, k)) return false; }" <>
      td "return true;" <>
    td "}"
  , td "function " <> _map <> td "(f, o) {" <>
      td "if (__isArray(o)) { return o.map(f); }" <>
      td "else if (__isObject(o)) {" <> 
        td "var res = []; for (var x in o) { if (hasOwnProperty.call(o, x)) { res.push(f(o[x])); }} return res;" <>
      td "}" <>
      td "else { throw ('cannot iterate over ' + o); }" <>
    td "}"
  , td "function " <> _mapIdx <> td "(f, o) {" <>
      td "if (__isArray(o)) { var idx = -1; return o.map(function(x) { idx++; return f(idx, x); }); }" <>
      td "else if (__isObject(o)) {" <>
        td "var res = []; for (var x in o) { if (hasOwnProperty.call(o, x)) { res.push(f(x, o[x])); }} return res; }" <>
      td "else { throw ('cannot iterate over ' + o); }" <>
    td "}"
  ]

topToJs :: Template -> Doc
topToJs t = fun [_dollar, td "__userfuns"] $
  letIn [_dot := _dollar] $
    toExpr (predefsDecl : enrichPredefs : prelude ++ [toJs t])
  where predefsDecl = td "var " <> _funs <> td "=" <> predefs
        enrichPredefs = td "for (var key in __userfuns) { " <>
                        _funs <> td "[key] = __userfuns[key]; }"

class ToJs a where
  toJs :: a -> Doc

instance ToJs Template where
  toJs (Expression p) = parens (toJs p)
  toJs (Concat []) = quotes mempty
  toJs (Concat (Definition x t : ts)) =
    letIn [td x := f] $
      toJs (Concat ts)
    where f = fun [_dot] (toJs t)
  toJs (Concat (t:ts)) = toJs t <> td "+" <> toJs (Concat ts)
  toJs (TemplateCall x p) = app (td x) [toJs p]
  toJs (Range (Pipeline [VarDef [x] p]) t1 t0) =
    letIn [_tmp := toJs p] $
      ifThenElse (app _isEmpty [_tmp])
        (toJs t0)
        (jConcat $ app _map [fun [_x] $ letIn [_dot := _x] (toJs t1), _tmp])
    where _x = toJs x
  -- UHC is buggy on deep patterns
  toJs (Range (Pipeline [VarDef args@[_, _] p]) t1 t0) =
    let [_i, _x] = map toJs args
    in letIn [_tmp := toJs p] $
      ifThenElse (app _isEmpty [_tmp])
        (toJs t0)
        (jConcat $ app _mapIdx [fun [_i, _x] $ letIn [_dot := _x] (toJs t1), _tmp])
  toJs (Range p t1 t0) =
    letIn [_tmp := toJs p] $
      ifThenElse (app _isEmpty [_tmp])
        (toJs t0)
        (jConcat $ app _map [fun [_dot] $ toJs t1, _tmp])
  toJs (With (Pipeline [VarDef [x] p]) t1 t0) =
    letIn [_x := toJs p] $
      ifThenElse (isEmptyString (parens _x <> (td ".toString()")))
        (toJs t0)
        (letIn [_dot := _x] $ toJs t1)
    where _x = toJs x
  toJs (With p t1 t0) =
    letIn [_tmp := toJs p] $
      ifThenElse (isEmptyString (parens _tmp <> (td ".toString()")))
        (toJs t0)
        (letIn [_dot := _tmp] $ toJs t1)
  toJs (If a b c) = ifThenElse (toJs a) (toJs b) (toJs c)
  toJs (Text t) = quotes (td $ escape t)

instance ToJs Pipeline where
  toJs (Pipeline []) = (td "")
  toJs (Pipeline (e:es)) = pipe (cook e) es 
    where cook (Apply f args) | null args = error "ill-formed AST"
                              | otherwise = app (toJs f) (map toJs args)
          cook e = letIn [_tmp := toJs e] $
                     ifThenElse (app _isFun [_tmp]) (app _tmp []) _tmp
          pipe arg [] = arg
          pipe arg (Apply f args : es) = 
            pipe (app (toJs f) ((map toJs args) ++ [arg])) es
          pipe arg (e : es) = pipe (app (toJs e) [arg]) es

instance ToJs Expr where
  toJs (Bool True) = (td "true") 
  toJs (Bool False) = (td "false") 
  toJs (Integer i) = td (show i)
  toJs (Double d) = td (show d)
  toJs (AccessChain var fields) = access (toJs var) fields
    where access var fields = inter (td ".") (var : map td fields)

instance ToJs Var where
  toJs (Plain x) = _funs <> td "." <> td x
  toJs (Dollar x) = _dollar <> td x
  toJs Dot = _dot
  
